home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / ppp.zip / PPP.PAS < prev    next >
Pascal/Delphi Source File  |  1991-03-29  |  29KB  |  833 lines
  1. (* PPP - Author: Martin Bless 890224                           *)
  2. (* Pretty Print Pascal. Compiled with Turbo-Pascal 5.0         *)
  3.  
  4. {$UNDEF debug}          (* may be changed to DEFINE            *)
  5. {$UNDEF sort}           (* use DEFINE for nonordered keywords  *)
  6. {$A+,B-,D+,E+,F-,I+,L-,N-,O-,R+,S+,V-}
  7. {$M 16384,0,655360}
  8.  
  9. PROGRAM PPP;
  10.  
  11. USES
  12.   Crt, Dos;
  13.  
  14. CONST
  15.   tabLen        =   8;                 (* # of blanks for tabs *)
  16.   nKeyWords     = 245;                 (* number of keywords   *)
  17.   keyWordLength =  25;                 (* length of keywords   *)
  18.   idSet    = ['A'..'Z', 'a'..'z',      (* legal chars for      *)
  19.               '0'..'9','_'];           (*   identifier         *)
  20.   printSet = [#3..#6, #21, #32..#126,  (* printable chars of   *)
  21.               #128..#254];             (*   NEC-P6             *)
  22.  
  23. TYPE
  24.   DestType       = (console, printer, necP6, datei, norton);
  25.   KeyWordType    = STRING[ keyWordLength];
  26.   KeyWordsType   = ARRAY[ 1..nKeyWords] OF KeyWordType;
  27.   ColorTableType = ARRAY[ 0..7] OF BYTE;
  28.  
  29. CONST
  30.   colorTable: ColorTableType =(
  31.     $07,   (* light grey:=hellgrau *)     (* normal text       *)
  32.     $07,   (* hellgrau *)                 (* comments          *)
  33.     $0F,   (* weia     *)                 (* keyword class '1' *)
  34.     $07,   (* hellgrau *)                 (* keyword class '2' *)
  35.     $07,   (* hellgrau *)                 (* keyword calss '3' *)
  36.     $07,   (* hellgrau *)                 (* keyword class '4' *)
  37.     $07,   (* hellgrau *)                 (* keyword class '5' *)
  38.     $07    (* hellgrau *)                 (* keyword class '6' *)
  39.     );
  40.  
  41. (* IMPORTANT: keywords in alphabetic order, CASE INDEPENDENT!  *)
  42. (*            MUST have trailing blank and class number        *)
  43.   key:KeyWordsType = (
  44. 'Abs 2', 'ABSOLUTE 1', 'Addr 2', 'AND 1', 'Append 2', 'Arc 2',
  45. 'ArcTan 2', 'ARRAY 1', 'Assign 2', 'AssignCrt 2', 'Bar 2',
  46. 'Bar3D 2', 'BEGIN 1', 'BlockRead 2', 'BlockWrite 2', 'BOOLEAN 1',
  47. 'BYTE 1', 'CASE 1', 'CHAR 1', 'ChDir 2', 'Chr 2', 'Circle 2',
  48. 'ClearDevice 2', 'ClearViewPort 2', 'Close 2', 'CloseGraph 2',
  49. 'ClrEol 2', 'ClrScr 2', 'Concat 2', 'CONST 1', 'Copy 2', 'Cos 2',
  50. 'CSeg 2', 'DEC 1', 'Delay 2', 'Delete 2', 'DelLine 2',
  51. 'DetectGraph 2', 'DiskFree 2', 'DiskSize 2', 'Dispose 2',
  52. 'DIV 1', 'DO 1', 'DosExitCode 2', 'DOWNTO 1', 'DrawPoly 2',
  53. 'DSeg 2', 'Ellipse 2', 'ELSE 1', 'END 1', 'Eof 2', 'Eoln 2',
  54. 'Erase 2', 'Exec 2', 'EXIT 1', 'Exp 2', 'EXTERNAL 1', 'FALSE 1',
  55. 'FILE 1', 'FilePos 2', 'FileSize 2', 'FillChar 2', 'FillPoly 2',
  56. 'FindFirst 2', 'FindNext 2', 'FloodFill 2', 'Flush 2', 'FOR 1',
  57. 'FORWARD 1', 'Frac 2', 'FreeMem 2', 'FUNCTION 1',
  58. 'GetArcCoords 2', 'GetAspectRatio 2', 'GetBkColor 2',
  59. 'GetColor 2', 'GetDate 2', 'GetDir 2', 'GetFAttr 2',
  60. 'GetFillSettings 2', 'GetFTime 2', 'GetGraphMode 2',
  61. 'GetImage 2', 'GetIntVec 2', 'GetLineSettings 2', 'GetMaxX 2',
  62. 'GetMaxY 2', 'GetMem 2', 'GetPalette 2', 'GetPixel 2',
  63. 'GetTextSettings 2', 'GetTime 2', 'GetViewSettings 2', 'GetX 2',
  64. 'GetY 2', 'GOTO 1', 'GotoXY 2', 'GraphErrorMsg 2',
  65. 'GraphResult 2', 'HALT 2', 'Hi 2', 'HighVideo 2', 'IF 1',
  66. 'ImageSize 2', 'IMPLEMENTATION 1', 'IN 1', 'INC 1',
  67. 'InitGraph 2', 'INLINE 1', 'Insert 2', 'InsLine 2', 'Int 2',
  68. 'INTEGER 1', 'INTERFACE 1', 'INTERRUPT 1', 'Intr 2',
  69. 'IOResult 2', 'Keep 2', 'KeyPressed 2', 'LABEL 1', 'Length 2',
  70. 'Line 2', 'LineRel 2', 'LineTo 2', 'Ln 2', 'Lo 2', 'LongInt 1',
  71. 'LowVideo 2', 'Mark 2', 'MaxAvail 2', 'MemAvail 2', 'MkDir 2',
  72. 'MOD 1', 'Move 2', 'MoveRel 2', 'MoveTo 2', 'MsDos 2', 'New 2',
  73. 'NIL 1', 'NormVideo 2', 'NoSound 2', 'NOT 1', 'Odd 2', 'OF 1',
  74. 'Ofs 2', 'OR 1', 'Ord 2', 'OutText 2', 'OutTextXY 2', 'PACKED 1',
  75. 'PackTime 2', 'ParamCount 2', 'ParamStr 2', 'Pi 2', 'PieSlice 2',
  76. 'POINTER 1', 'Pos 2', 'Pred 2', 'PROCEDURE 1', 'PROGRAM 1',
  77. 'Ptr 2', 'PutImage 2', 'PutPixel 2', 'Random 2', 'Randomize 2',
  78. 'Read 2', 'ReadKey 2', 'ReadLn 2', 'RECORD 1', 'Rectangle 2',
  79. 'Release 2', 'Rename 2', 'REPEAT 1', 'Reset 2', 'RestoreCrt 2',
  80. 'RestoreCrtMode 2', 'Rewrite 2', 'RmDir 2', 'Round 2', 'Seek 2',
  81. 'SeekEof 2', 'SeekEoln 2', 'Seg 2', 'SET 1', 'SetActivePage 2',
  82. 'SetAllPalette 2', 'SetBkColor 2', 'SetColor 2', 'SetDate 2',
  83. 'SetFAttr 2', 'SetFillPattern 2', 'SetFillStyle 2', 'SetFTime 2',
  84. 'SetGraphMode 2', 'SetIntVec 2', 'SetLineStyle 2',
  85. 'SetPalette 2', 'SetTextBuf 2', 'SetTextJustify 2',
  86. 'SetTextStyle 2', 'SetTime 2', 'SetViewPort 2',
  87. 'SetVisualPage 2', 'SHL 1', 'ShortInt 1', 'SHR 1', 'Sin 2',
  88. 'SizeOf 2', 'Sound 2', 'SPtr 2', 'Sqr 2', 'Sqrt 2', 'SSeg 2',
  89. 'Str 2', 'STRING 1', 'Succ 2', 'Swap 2', 'TEXT 1',
  90. 'TextBackground 2', 'TextColor 2', 'TextHeight 2', 'TextMode 2',
  91. 'TextWidth 2', 'THEN 1', 'TO 1', 'TRUE 1', 'Trunc 2',
  92. 'Truncate 2', 'TYPE 1', 'UNIT 1', 'UnpackTime 2', 'UNTIL 1',
  93. 'UpCase 2', 'USES 1', 'Val 2', 'VAR 1', 'WhereX 2', 'WhereY 2',
  94. 'WHILE 1', 'Window 2', 'WITH 1', 'WORD 1', 'Write 2',
  95. 'WriteLn 2', 'XOR 1'
  96. );
  97.  
  98. VAR (* general global *)
  99.   ch:       CHAR;               (* current char of source file *)
  100.   lk:       CHAR;               (* last key                    *)
  101.   goFlag:   CHAR;               (* #32 = ' ' = go!             *)
  102.  
  103. VAR (* keyword finding *)
  104.   keyIndex: WORD;               (* index of keyword found      *)
  105.   idPos:    WORD;               (* position in id string       *)
  106.   id:       KeyWordType;        (* identifier buffer           *)
  107.  
  108. VAR (* program flow *)
  109.   convert: BOOLEAN;             (* convert KeyWords?           *)
  110.  
  111. VAR  (* printing *)
  112.   dest:      DestType;       (* output destiniation            *)
  113.   lpp:       WORD;           (* lines per page                 *)
  114.   cpl:       WORD;           (* columns per line               *)
  115.   colCnt:    WORD;           (* current column                 *)
  116.   lineCnt:   WORD;           (* current line                   *)
  117.   pageCnt:   WORD;           (* current page                   *)
  118.   lMargin:   WORD;           (* left margin in # of blanks     *)
  119.   inComment: BOOLEAN;        (* true if comment printing is on *)
  120.   inKeyWord: BOOLEAN;        (* true if keyword printing is on *)
  121.   color:     WORD;           (* index to colorTable            *)
  122.  
  123. VAR (* for Norton Guides *)
  124.   totalBytes: WORD;              (* count all bytes output     *)
  125.   shortCnt:   WORD;              (* count # of short entries   *)
  126.  
  127. VAR  (* files *)
  128.   f1File:         Text;                     (* input file      *)
  129.   f2File:         Text;                     (* output file     *)
  130.   f1Name, f2Name: STRING[ 80];              (* fileNames       *)
  131.   f1Open, f2Open: BOOLEAN;                  (* open indicators *)
  132.  
  133. FUNCTION LastKey:CHAR;     (* get last key pressed, #0 if none *)
  134. VAR
  135.   rk: CHAR;
  136. BEGIN
  137.   rk := #0;
  138.   IF KeyPressed THEN BEGIN;
  139.     rk := ReadKey;
  140.     IF rk = #0 THEN BEGIN                  (* eat function key *)
  141.        rk := ReadKey;
  142.        rk := #0;
  143.     END;
  144.   END;
  145.   LastKey := rk;
  146. END;
  147.  
  148. FUNCTION WaitKey: CHAR;                   (* wait for keypress *)
  149. BEGIN
  150.   WHILE NOT KeyPressed DO;                (* loop              *)
  151.   WaitKey := LastKey;
  152. END;
  153.  
  154. FUNCTION UpStr( s:STRING):STRING;         (* convert string to *)
  155. VAR                                       (* upper case        *)
  156.   c: WORD;
  157. BEGIN
  158.   FOR c:= 1 TO Length( s) DO BEGIN
  159.     UpStr[c] := UpCase( s[c]);
  160.   END;
  161.   UpStr[0] := s[0];                      (* set correct length *)
  162. END;
  163.  
  164.  
  165. {$IFDEF sort}
  166. PROCEDURE SortKeyWords;                   (* case independent! *)
  167. VAR
  168.   x, y: KeyWordType;
  169.  
  170. PROCEDURE QSort( l, r:WORD);           (* Quicksort (rekursiv) *)
  171. VAR
  172.   i, j: WORD;
  173. BEGIN
  174.   i := l;
  175.   j := r;
  176.   x := UpStr( key[ (l+r) DIV 2]);         (* case independent! *)
  177.   REPEAT
  178.     WHILE UpStr( key[ i]) < x DO INC(i);  (* case independent! *)
  179.     WHILE x < UpStr( key[ j]) DO DEC(j);  (* case independent! *)
  180.     IF i <= j THEN BEGIN
  181.       y       := key[ i];
  182.       key[ i] := key[ j];
  183.       key[ j] := y;
  184.       INC( i);
  185.       DEC( j);
  186.     END;
  187.   UNTIL i > j;
  188.   IF l < j THEN QSort( l, j);
  189.   IF i < r THEN QSort( i, r);
  190. END; (* QSort *)
  191.  
  192. BEGIN
  193.   IF nKeyWords > 0 THEN QSort( 1, nKeyWords);
  194. END; (* SortKeyWords *)
  195. {$ENDIF}
  196.  
  197. {$IFDEF debug}
  198. PROCEDURE ShowKeyWords;
  199. VAR
  200.   c: WORD;
  201. BEGIN
  202.   FOR c:= 1 TO nKeyWords DO BEGIN
  203.     WriteLn( c:5, '':5, key[c]);
  204.   END;
  205. END;
  206. {$ENDIF}
  207.  
  208. FUNCTION Space( n:BYTE):STRING;   (* return string of n spaces *)
  209. VAR
  210.   c: WORD;
  211. BEGIN
  212.   Space[0] := Chr(n);
  213.   FOR c := 1 TO n DO BEGIN
  214.     Space[c] := ' ';
  215.   END;
  216. END;
  217.  
  218. PROCEDURE SendCh( c:CHAR);    (* all output done here charwise *)
  219. BEGIN                         (* IOResult may be checked       *)
  220.   (*$I-*)
  221.   Write( f2File, c);          (* !!!!! OUTPUT TO f2File !!!!!  *)
  222.   (*$I+*)
  223.   IF IOResult <> 0 THEN BEGIN      (* stop program immediately *)
  224.     IF f1Open THEN Close( f1File); (* try a clean exit         *)
  225.     IF f2Open THEN Close( f2File); (*                          *)
  226.     WriteLn('PPP - Error on output to '#39+
  227.              f2Name+#39);          (* let user know            *)
  228.     Halt( 1);                      (* abort with errorlevel 1  *)
  229.   END;
  230.   INC( totalBytes);           (* count bytes for norton guides *)
  231. END;
  232.  
  233. PROCEDURE SendStr( s:STRING);                   (* send string *)
  234. VAR
  235.   c: WORD;
  236. BEGIN
  237.   FOR c:= 1 TO Length( s) DO BEGIN
  238.     SendCh( s[c]);
  239.   END;
  240. END;
  241.  
  242. PROCEDURE AbortProgram( msg:STRING);      (* no msg = no error *)
  243. BEGIN
  244.   IF f2Open AND (msg<>'') AND
  245.      (colCnt <> 1) THEN
  246.   BEGIN
  247.     SendStr( #13#10);                     (* try to close line *)
  248.   END;
  249.   IF f1Open THEN Close( f1File);
  250.   IF f2Open THEN Close( f2File);
  251.   IF msg[0] > #0 THEN BEGIN
  252.     WriteLn;
  253.     WriteLn( msg);
  254.     Halt( 1);                       (* abort with errorlevel 1 *)
  255.   END;
  256.   Halt( 0);              (* abort with errorlevel 0 (no error) *)
  257. END;
  258.  
  259. FUNCTION DateStr: STRING;                  (* returns TT.MM.JJ *)
  260. VAR
  261.   yy, mm, dd, dow: WORD;
  262.   ys, ms, ds:      STRING[4];
  263. BEGIN
  264.   GetDate ( yy, mm, dd, dow);
  265.   Str( dd:2, ds);   IF dd<10 THEN ds[1] := '0';
  266.   Str( mm:2, ms);   IF mm<10 THEN ms[1] := '0';
  267.   Str( yy:4, ys);
  268.   DateStr := ds+'.'+ms+'.'+Copy(ys,3,2);
  269. END;
  270.  
  271. FUNCTION TimeStr: STRING;                  (* returns HH:MM:SS *)
  272. VAR
  273.   hh, mm, sec, sec100: WORD;
  274.   hs, ms, ss:          STRING[4];
  275. BEGIN
  276.   GetTime ( hh, mm, sec, sec100);
  277.   Str( hh:2, hs);   IF  hh<10 THEN hs[1] := '0';
  278.   Str( mm:2, ms);   IF  mm<10 THEN ms[1] := '0';
  279.   Str( sec:2, ss);  IF sec<10 THEN ss[1] := '0';
  280.   TimeStr := hs+':'+ms+':'+ss;
  281. END;
  282.  
  283. PROCEDURE KeyWordOn;                    (* a keyword follows   *)
  284. BEGIN
  285.   inKeyWord := TRUE;
  286.   CASE dest OF
  287.     console: TextAttr := colorTable[ color];
  288.     necP6  : IF color = 2 THEN BEGIN
  289.                SendStr( #27'E');        (* Shadowed font ON *)
  290.              END;
  291.     printer: ;
  292.     datei  : ;
  293.     norton : IF color = 2 THEN BEGIN
  294.                SendStr('^B');           (* highlighted ON      *)
  295.              END;
  296.   END;
  297. END;
  298.  
  299. PROCEDURE KeyWordOff;                   (* end of keyword      *)
  300. BEGIN
  301.   inKeyWord := FALSE;
  302.   CASE dest OF
  303.     console: TextAttr := colorTable[ 0];
  304.     necP6  : IF color = 2 THEN BEGIN
  305.                SendStr( #27'F');        (* Shadowed font OFF *)
  306.              END;
  307.     printer: ;
  308.     datei  : ;
  309.     norton : IF color = 2 THEN BEGIN
  310.                SendStr('^N');           (* back to normal      *)
  311.              END;
  312.   END;
  313. END;
  314.  
  315. PROCEDURE CommentOn;                    (* a comment follows   *)
  316. BEGIN
  317.   inComment := TRUE;
  318.   CASE dest OF
  319.     necP6:    SendStr(#27'4');                (* italics ON    *)
  320.     console:  TextAttr := colorTable[1];      (* comment color *)
  321.     printer: ;
  322.     datei  : ;
  323.   END;
  324. END;
  325.  
  326. PROCEDURE CommentOff;                        (* end of comment *)
  327. BEGIN
  328.   inComment := FALSE;
  329.   CASE dest OF
  330.     necP6:    SendStr(#27'5');                 (* italics OFF  *)
  331.     Console:  TextAttr := colorTable[0];       (* normal color *)
  332.     printer: ;
  333.     datei  : ;
  334.   END;
  335. END;
  336.  
  337. PROCEDURE PrintTitle;     (* only when printer format selected *)
  338. VAR
  339.   c, tabPos:   WORD;
  340.   s:           STRING[50];
  341.   myInComment: BOOLEAN;
  342.   myInKeyWord: BOOLEAN;
  343. BEGIN
  344.   IF NOT (dest IN
  345.      [printer, necP6]) THEN
  346.   BEGIN
  347.     EXIT;                                (* if not for printer *)
  348.   END;
  349.   myInComment := inComment;    (* print headline always normal *)
  350.   myInKeyWord := inKeyWord;
  351.   IF inComment THEN CommentOff;
  352.   IF inKeyWord THEN KeyWordOff;
  353.   SendCh( #13);             (* print head to beginning of line *)
  354.   FOR c:= 1 TO 2 DO BEGIN
  355.     SendCh( #10);                               (* empty lines *)
  356.     INC( lineCnt);
  357.   END;
  358.   SendStr( Space( lMargin));                    (* left margin *)
  359.   SendStr( DateStr+'  '+TimeStr);
  360.   Str( pageCnt:3, s);
  361.   SendStr( '  Seite'+s);                        (* page number *)
  362.   colCnt := lMargin+1+8+2+8+7+3;        (* adjust column count *)
  363.   SendStr( Space( cpl - colCnt - Length( f1Name)+1));
  364.   SendStr( f1Name );        (* print file name right justified *)
  365.   SendCh( #13);                   (* back to beginning of line *)
  366.   colCnt := 1;
  367.   FOR c:= 1 TO 3 DO BEGIN
  368.     SendCh( #10);                             (* 2 empty lines *)
  369.     INC( lineCnt);
  370.   END;
  371.   IF myInComment THEN CommentOn;      (* restore printing mode *)
  372.   IF myInKeyWord THEN KeyWordOn;
  373. END;
  374.  
  375. FUNCTION ShortString:String;             (* for norton guides  *)
  376. VAR                                      (* insert: !SHORT ... *)
  377.   s: STRING[10];
  378. BEGIN
  379.   INC( shortCnt);
  380.   Str( shortCnt, s);
  381.   ShortString := '!SHORT '+f1Name+' ...'+s+#13+#10;
  382. END;
  383.  
  384. PROCEDURE LeftMargin;           (* send blanks for left margin *)
  385. VAR
  386.   c: WORD;
  387. BEGIN
  388.   FOR c := 1 TO lMargin DO BEGIN
  389.     SendCh( ' ');
  390.     INC( colCnt);                             (* count columns *)
  391.   END;
  392. END;
  393.  
  394. PROCEDURE NextPage;                      (* next printing page *)
  395. BEGIN
  396.   INC( pageCnt);                                (* count pages *)
  397.   colCnt  := 1;
  398.   lineCnt := 1;
  399.   IF NOT (dest IN [console, printer, necP6]) THEN BEGIN
  400.     EXIT;        (* nothing inserted, if destination is a file *)
  401.   END;
  402.   IF dest = console THEN BEGIN
  403.     IF goFlag <> ' ' THEN BEGIN
  404.       Write( f2File, Space( 60), '(Space-) Bar ...');
  405.       lk := WaitKey;
  406.       IF lk=#27 THEN BEGIN               (* ESCape key pressed *)
  407.         AbortProgram( '');               (* aborted by user    *)
  408.       END;
  409.       IF lk <> #0 THEN BEGIN
  410.         goFlag := lk;                    (* save last key      *)
  411.       END;
  412.       SendCh( #13);
  413.       ClrEol;
  414.     END;
  415.     EXIT;
  416.   END;
  417.   SendCh( #13);                    (* back to column 1         *)
  418.   SendCh( #12);                    (* send FORM FEED character *)
  419. END;
  420.  
  421. PROCEDURE NextLine;                (* next line to print       *)
  422. BEGIN
  423.   SendCh( #13);
  424.   colCnt := 1;
  425.   SendCh( #10);
  426.   INC( lineCnt);
  427.   IF (lineCnt >= lpp) THEN BEGIN     (* beyond lines per page? *)
  428.      NextPage;
  429.   END;
  430.   IF totalBytes > 11500 THEN BEGIN           (* about 12000 ... *)
  431.     IF dest = norton THEN BEGIN
  432.       SendStr( ShortString);                 (* chop to pieces *)
  433.     END;
  434.     totalBytes := 0;
  435.   END;
  436. END;
  437.  
  438. PROCEDURE CheckColumn;         (* check next printing position *)
  439. BEGIN
  440.   IF (colCnt > cpl) AND        (* beyond columns per line?     *)
  441.      (dest IN [printer, necP6, norton]) THEN
  442.   BEGIN
  443.      NextLine;
  444.   END;
  445.   IF (colCnt=1) AND (lineCnt=1) THEN BEGIN
  446.     PrintTitle;
  447.   END;
  448.   IF colCnt=1 THEN BEGIN
  449.     LeftMargin;
  450.   END;
  451. END;
  452.  
  453. PROCEDURE CheckTopOfForm;                   (* at top of form? *)
  454. BEGIN
  455.   IF (colCnt=1) AND (lineCnt=1) THEN BEGIN
  456.     PrintTitle;
  457.   END;
  458. END;
  459.  
  460. PROCEDURE ListCh( c:CHAR);     (* all characters to be printed *)
  461.                                (* and formatted have to pass   *)
  462. BEGIN                          (* this filter                  *)
  463.   IF c = #10 THEN BEGIN
  464.      CheckTopOfForm;           (* print title, if at line 1    *)
  465.      NextLine;
  466.      EXIT;
  467.   END;
  468.   IF c IN printSet THEN BEGIN  (* Is it a printable character? *)
  469.      CheckColumn;              (* end of line or pos 1?        *)
  470.      SendCh( c);               (* finally send char            *)
  471.      INC( colCnt);             (* adjust column counter        *)
  472.   END;
  473.   IF (c = '^') AND (dest=norton) THEN BEGIN
  474.     SendCh('^');     (* send double up arrow for norton guides *)
  475.   END;
  476.   IF c = #9 THEN BEGIN         (* tabulator?                   *)
  477.     ListCh(' ');               (* RECURSION!                   *)
  478.     WHILE ((colCnt-lMargin) MOD tabLen) <> 1 DO BEGIN
  479.       ListCh(' ');             (* tab to pos 1,9,17 ...        *)
  480.     END;
  481.   END;
  482.   (* ignore unprintable characters here! *)
  483. END;
  484.  
  485. PROCEDURE ListString( s:STRING);      (* send string to ListCh *)
  486. VAR
  487.   ch: CHAR;
  488. BEGIN
  489.   FOR ch := #1 TO s[0] DO BEGIN
  490.     ListCh( s[ ORD(ch)] );
  491.   END;
  492. END;
  493.  
  494. PROCEDURE InitPrinting;
  495. BEGIN                           (* set up defaults             *)
  496.   colCnt  := 1;                 (* column count                *)
  497.   lineCnt := 1;                 (* line count                  *)
  498.   pageCnt := 1;                 (* page count                  *)
  499.   lMargin := 0;                 (* # of blanks for left margin *)
  500.   totalBytes := 0;
  501.   shortCnt   := 0;
  502.   inComment  := FALSE;
  503.   inKeyWord  := FALSE;
  504.   CASE dest OF
  505.  
  506.   datei: BEGIN
  507.       lpp     := $FFFF;             (* not relevant            *)
  508.       cpl     := $FFFF;             (* not relevant            *)
  509.     END;
  510.  
  511.   console: BEGIN                    (* To screen:              *)
  512.       lpp     := 24;                (* stop after 24 lines     *)
  513.       cpl     := 80;                (* 80 columns per line     *)
  514.       SendStr( #13#10#10);          (* start with empty line   *)
  515.     END;
  516.  
  517.   printer: BEGIN                    (* To standard printer:    *)
  518.      lpp     := 66;                 (* lines per page          *)
  519.      cpl     := 80;                 (* columns per line        *)
  520.      lMargin := 8;                  (* 8 * 0.254 cm = 2.032 cm *)
  521.     END;
  522.  
  523.   norton: BEGIN                           (* To norton guides: *)
  524.      lMargin := 1;                        (* much better!        *)
  525.      lpp     := $FFFF;
  526.      cpl     := 77;                   (* links + rechts 1 #32  *)
  527.      SendStr( ShortString);           (* start 1st short entry *)
  528.      SendStr( '^B'+f1Name+            (* and include file name *)
  529.               '^N'#13#10#13#10);
  530.     END;
  531.  
  532.   necP6: BEGIN
  533.     SendStr(#27#0);            (* reset printer                *)
  534.     SendStr(#27'R'#0);         (* american fontset             *)
  535.     SendStr(#27'M');           (* 12 CPI = 96 cpl              *)
  536.     SendStr(#27'l'#12);        (* left margin                  *)
  537.     lpp     := 69;             (* use 69 of 72                 *)
  538.     cpl     := 80;             (* columns per line (12+80+4)   *)
  539.     lMargin :=  0;             (* hardware left margin         *)
  540.     END;
  541.   END; (* case *)
  542. END;
  543.  
  544. PROCEDURE CondFF;                     (* conditional form feed *)
  545. BEGIN                                 (* avoid empty page      *)
  546.   IF dest IN [necP6, printer] THEN BEGIN
  547.      IF (colCnt > 1) OR (lineCnt > 1) THEN BEGIN
  548.        NextPage;
  549.      END;
  550.   END;
  551. END;
  552.  
  553. PROCEDURE Angaben;          (* get parameters from commandline *)
  554. VAR
  555.   par3:  STRING;
  556. BEGIN
  557.   convert := (Pos('-C',UpStr(ParamStr(4)))=0);  (* convertflag *)
  558.   f1Open := FALSE;
  559.   f2Open := FALSE;
  560.   f1Name := ParamStr( 1);                 (* input filename    *)
  561.   f1Name[1] := UpCase( f1Name[1]);        (* 1st char to upper *)
  562.   IF Pos('.',f1Name) = 0 THEN BEGIN       (* check for .PAS    *)
  563.      f1Name := f1Name + '.PAS';
  564.   END;
  565.   Assign( f1File, f1Name);
  566.   (*$I-*)
  567.   Reset( f1File);                         (* open INPUT file   *)
  568.   (*$I+*)
  569.   IF IOResult <> 0 THEN BEGIN
  570.     AbortProgram('PPP - Error: file '#39+f1Name+#39' not found');
  571.   END;
  572.   f1Open := TRUE;
  573.  
  574.   IF ParamCount > 1 THEN
  575.     f2Name := UpStr( ParamStr(2))          (* output file name *)
  576.   ELSE BEGIN
  577.     f2Name:='CON';                         (* CON is default   *)
  578.   END;
  579.   IF (Pos('.',f2Name)=0) AND           (* copy Ext from input? *)
  580.      ('CON' <> f2Name)   AND
  581.      ('PRN' <> f2Name)   THEN
  582.   BEGIN
  583.     f2Name := f2Name+Copy( f1Name, Pos('.',f1Name),255);
  584.   END;
  585.   IF UpStr(f1Name) = UpStr(f2Name) THEN BEGIN
  586.     AbortProgram('PPP - Error: In- and output file '#39 +
  587.                    f1Name + #39' identically');
  588.   END;
  589.   IF f2Name = 'CON' THEN
  590.     AssignCrt( f2File)                     (* use CRT          *)
  591.   ELSE BEGIN
  592.     Assign(  f2File, f2Name);
  593.   END;
  594.   IF Pos('-A', UpStr(ParamStr(4)))>0 THEN BEGIN
  595.     (*$I-*)
  596.     Append( f2File);                                 (* Append *)
  597.     (*$I+*)
  598.     IF IOResult=0 THEN BEGIN
  599.       f2Open := TRUE;
  600.     END;
  601.   END;
  602.   IF NOT f2Open THEN BEGIN
  603.     (*$I-*)
  604.     Rewrite( f2File);                               (* Rewrite *)
  605.     (*$I+*)
  606.     IF IOResult = 0 THEN BEGIN
  607.       f2Open := TRUE;
  608.     END;
  609.   END;
  610.   IF NOT f2Open THEN BEGIN
  611.     AbortProgram('PPP - Error while opening file '+
  612.                   #39+f2Name+#39);
  613.   END;
  614.   IF ParamCount > 2 THEN
  615.       par3 := UpStr( ParamStr(3))          (* find destination *)
  616.   ELSE BEGIN
  617.     par3 := '';                            (* defaults ...     *)
  618.     IF f2Name='CON' THEN par3 := 'CON';
  619.     IF f2Name='PRN' THEN par3 := 'PRN';
  620.   END;
  621.   dest := datei;
  622.   IF par3 = 'CON'     THEN BEGIN dest:=console; EXIT; END;
  623.   IF par3 = 'NECP6'   THEN BEGIN dest:=necP6;   EXIT; END;
  624.   IF par3 = 'PRN'     THEN BEGIN dest:=printer; EXIT; END;
  625.   IF par3 = 'NORTON'  THEN BEGIN dest:=norton;  EXIT; END;
  626. END;
  627.  
  628. PROCEDURE GetCh;             (* read next char from INPUT file *)
  629. BEGIN
  630.   IF Eof( f1File) THEN BEGIN
  631.     IF colCnt <> 1 THEN BEGIN
  632.       SendStr( #13#10);                         (* finish line *)
  633.     END;
  634.     AbortProgram('PPP - WARNING: unexpected end of file');
  635.   END;
  636.   Read( f1File, ch);
  637. END;
  638.  
  639. PROCEDURE Copy;
  640. BEGIN
  641.   ListCh(  ch);                  (* current char to formatter  *)
  642.   GetCh;                         (* get next one               *)
  643. END;
  644.  
  645. FUNCTION NoKeyWord:BOOLEAN;    (* Binary search. Returns TRUE, *)
  646. VAR                            (* if current identifier is not *)
  647.   i,l,r,m: WORD;               (* a keyword                    *)
  648. BEGIN
  649.   l := 1;
  650.   r := nKeyWords;
  651.   id[ idPos] := ' ';           (* mark end of identifier       *)
  652.   REPEAT
  653.     m:=(l+r) DIV 2;
  654.     keyIndex := m;
  655.     i:=1;
  656.     WHILE (UpCase(id[i])=UpCase(key[m,i])) AND
  657.           (id[i] <> ' ') DO
  658.     BEGIN
  659.       INC( i);
  660.     END;
  661.     IF UpCase(id[i])<=UpCase(key[m,i]) THEN BEGIN r:=m-1; END;
  662.     IF UpCase(id[i])>=UpCase(key[m,i]) THEN BEGIN l:=m+1; END;
  663.   UNTIL l>r;
  664.   NoKeyWord := (l=r+1);      (* TRUE if identifier = NoKeyWord *)
  665. END;
  666.  
  667. PROCEDURE ProcessText;               (* whole input file       *)
  668. PROCEDURE ProcessChar;               (* deal with current char *)
  669. PROCEDURE Comment1;                  (* process ( * comment    *)
  670. BEGIN
  671.   Copy;                              (* process '*'            *)
  672.   REPEAT
  673.     WHILE ch <> '*' DO BEGIN         (* look for final '*'     *)
  674.       Copy;
  675.     END;
  676.     Copy;
  677.   UNTIL ch=')';                (* does ')' follow immediately? *)
  678.   Copy;
  679. END;
  680.  
  681. PROCEDURE ProcessUpTo( endCh: CHAR); (* copy until endCh found *)
  682. BEGIN
  683.   Copy;
  684.   WHILE ch <> endCh DO BEGIN
  685.     Copy;
  686.   END;
  687.   Copy;
  688. END;
  689.  
  690. PROCEDURE Collect;         (* collect chars to form identifier *)
  691. VAR
  692.   i: WORD;
  693. BEGIN
  694.   idPos := 1;
  695.   REPEAT
  696.     id[ idPos] := ch;
  697.     INC( idPos);
  698.     GetCh;
  699.   UNTIL (NOT( ch IN idSet)) OR (idPos > KeyWordLength);
  700.  
  701.   IF (idPos > keyWordLength) OR       (* shortcut evaluation   *)
  702.       NoKeyWord THEN                  (* MUST be ON! {$B-}     *)
  703.   BEGIN
  704.     FOR i := 1 TO idPos-1 DO BEGIN    (* NO keyword!           *)
  705.       ListCh(  id[i]);                (* print collected stuff *)
  706.     END;
  707.     EXIT;
  708.   END;
  709.                                     (* keyword found           *)
  710.   color := Ord( key[ keyIndex,      (* find keyword class      *)
  711.            idPos+1]) - Ord('1');
  712.   color := (color + 2) MOD 8;       (* make sure: 0..7         *)
  713.   KeyWordOn;                        (* signal start of keyword *)
  714.   FOR i:=1 TO idPos-1 DO BEGIN
  715.     ListCh( key[ keyIndex, i]);     (* print keyword           *)
  716.   END;
  717.   KeyWordOff;                       (* signal end of keyword   *)
  718. END; (* Collect *)
  719.  
  720. BEGIN (* ProcessChar *)
  721.   IF NOT convert THEN BEGIN           (* conversion inhibited? *)
  722.     Copy;                             (* yes, so copy only     *)
  723.     EXIT;
  724.   END;
  725.   IF (UpCase(ch)>='A') AND
  726.      (UpCase(ch)<='Z') THEN
  727.   BEGIN
  728.      Collect;                         (* collect identifier    *)
  729.      EXIT;
  730.   END;
  731.   IF ch = '(' THEN BEGIN       { a '(*' comment?                }
  732.      GetCh;
  733.      IF ch = '*' THEN BEGIN
  734.        CommentOn;              (* signal start of comment      *)
  735.        ListCh('(');
  736.        Comment1;               (* process this kind of comment *)
  737.        CommentOff;             (* signal end of comment        *)
  738.        EXIT;
  739.      END
  740.      ELSE BEGIN
  741.        ListCh('(');
  742.        EXIT;
  743.      END;
  744.   END;
  745.   IF ch = '{' THEN BEGIN       (* a '{' comment?               *)
  746.      CommentOn;                (* signal start of comment      *)
  747.      ProcessUpTo( '}');        (* process this kind of comment *)
  748.      CommentOff;               (* signal end of comment        *)
  749.      EXIT;
  750.   END;
  751.   IF ch = #39 THEN BEGIN
  752.        ProcessUpTo( #39);      (* process string constant      *)
  753.      EXIT;
  754.   END;
  755.   Copy;                        (* nothing special, so copy!    *)
  756. END; (* ProcessChar *)
  757.  
  758. BEGIN (* ProcessText *)
  759.   lk     := #0;                            (* last key pressed *)
  760.   goFlag := #13;                           (* #32 = ' ' = go   *)
  761.   GetCh;                                   (* provide 1st char *)
  762.   WHILE NOT(Eof(f1File)) AND
  763.         (lk<>#27) DO
  764.   BEGIN
  765.     ProcessChar;
  766.     lk     := LastKey;                     (* check keyboard   *)
  767.     IF lk <> #0 THEN BEGIN                 (* key pressed?     *)
  768.       goFlag := lk;                        (* save pressed key *)
  769.       IF (goFlag<>' ') AND
  770.          (dest=console) THEN
  771.       BEGIN
  772.         lineCnt := 9999;              (* pause after next line *)
  773.       END;
  774.     END;
  775.   END;
  776. END;  (* ProcessText *)
  777.  
  778. PROCEDURE Help;             (* redirect to printer with CTRL+P *)
  779. BEGIN
  780. WriteLn;
  781. WriteLn('PPP - Pretty Print Pascal. Autor: Martin Blea 890224');
  782. WriteLn('====================================================');
  783. WriteLn(
  784. 'correct start: PPP [file] [to] [how] [switches]');
  785. WriteLn(
  786. '        Example:  PPP Test.pas prn necp6  -p');
  787. WriteLn;
  788. WriteLn(' file: file name of source.       (1. Parameter)');
  789. WriteLn('       '#39'.PAS'#39' will be added if necessary.');
  790. WriteLn;
  791. WriteLn(' to:   output filename or device. (2. Parameter)');
  792. WriteLn('       (nothing)      = output to screen');
  793. WriteLn('       CON            = output to screen');
  794. WriteLn('       PRN            = output to printer');
  795. WriteLn(' how:                             (3. Parameter)');
  796. WriteLn('       (nothing)      = suitable for destination file');
  797. WriteLn('       CON            = screen like');
  798. WriteLn('       NECP6          = NEC P6 Printer like.');
  799. WriteLn('       NORTON         = for NORTON-Guides');
  800. WriteLn('       PRN            = vanilla printer');
  801. WriteLn;
  802. WriteLn(' switches:            (without spaces, 4. Parameter)');
  803. WriteLn('       -A             = append to destination file');
  804. WriteLn('       -C             = no keyword conversion');
  805. WriteLn('       -P             = no form-feed (FF) after last page');
  806. END;
  807.  
  808. BEGIN
  809.   Assign( OutPut, '');       (* allow redirection of help text *)
  810.   Append( OutPut);           (* append, the saver way ...      *)
  811.   IF ParamCount < 1 THEN     (* PPP = 0 args, give help        *)
  812.   BEGIN
  813.     Help;
  814.     Halt(0);                 (* assume no error                *)
  815.   END;
  816.   Angaben;                   (* get parameters and initialize  *)
  817.  
  818.   (*$IFDEF sort  *) SortKeyWords; (*$ENDIF*)
  819.   (*$IFDEF debug *) ShowKeyWords; (*$ENDIF*)
  820.  
  821.   InitPrinting;                (* setup parameters and devices *)
  822.   ProcessText;                 (* process the INPUT file       *)
  823.   IF colCnt <> 1 THEN BEGIN    (* print head not at pos 1?     *)
  824.     ListCh( #10);              (* finish line                  *)
  825.   END;
  826.   IF Pos('-P', UpStr(
  827.        ParamStr(4)))=0 THEN
  828.   BEGIN                        (* final FF?                    *)
  829.     CondFF;                    (* only, if not already at      *)
  830.   END;                         (*   end of page                *)
  831.   AbortProgram( '');           (* Shut down.                   *)
  832. END.                           (*   No message = No Error      *)
  833.